; File: EDIT.LSP  (C)		    03/06/91		Soft Warehouse, Inc.


(SETQ *INIT-WINDOW* "Edit")
(SETQ *WINDOW-TYPES* (SORT (ADJOIN "Edit" *WINDOW-TYPES*) 'STRING<))
(SETQ DRIVER 'WINDOWS)

(DEFUN "Edit" (COMMAND
	*FILE-NAME* *SCREEN*
	*FIND-STRG* *REPL-STRG* *EDIT-MODE* *TEXT-DIRTY*
	*ABOVE-POINT* *BELOW-POINT* *POINT-LINE* *MARK-LIST*
	*CURSOR-ROW* *CURSOR-COL* *POINT-ROW* *POINT-COL*
    *STAT-ROW* *STAT-COL* *UPDATE-FUNCTION* *LOCAL-DEMONS*
    *SCROLL-FLAG* *EDIT-STATUS* *INPUT-FILE* *OUTPUT-FILE*)
  ((EQ COMMAND 'CREATE-WINDOW)
    (SETQ *FILE-NAME* (STRING-TRIM " " *COMMAND-LINE*))
    ( ((EQ *FILE-NAME* ""))
      ((OR (OPEN-INPUT-FILE *FILE-NAME*)
	   (OPEN-INPUT-FILE (PACK* *FILE-NAME* '\. *DEFAULT-TYPE*)))
	(SETQ *FILE-NAME* (NORMALIZE-FILE-NAME (INPUT-FILE))
	      *BELOW-POINT* (READ-TEXT-FILE)) )
      (SETQ *FILE-NAME* "")
      (ERROR-BEEP) )
    (SETQ *POINT-LINE* (IF *BELOW-POINT* (POP *BELOW-POINT*) ""))
    (LIST "Edit"
	*FILE-NAME* (MAKE-LIST (WINDOW-ROWS) "")
	"" "" NIL NIL
	NIL *BELOW-POINT* *POINT-LINE*
	(COPY-TREE (MAKE-LIST 9 (CONS 0 0)))
	0 0 0 0) )
  ((EQ COMMAND 'CLOSE-WINDOW)
    (ABANDON-TEXT-FILE) )
  (SETQ *LOCAL-DEMONS* (CDDDR *EDIT-DEMONS*)
	*UPDATE-FUNCTION* 'UPDATE-EDIT
	*SCROLL-FLAG* T)
  (MAPL 'RPLACA (CDR (WINDOW-STATE)))
  (UNWIND-PROTECT
    (PROGN
      ((EQ COMMAND 'UPDATE-WINDOW)
	(SETQ *SCROLL-FLAG*)
	(SET-MARK *TEMP-POSN*)
	(JUMP-START-TEXT)
	(CURRENT-WINDOW T)
	(SETQ *SCREEN* (MAKE-LIST (WINDOW-ROWS) ""))
	(JUMP-TO-MARK *TEMP-POSN*)
	(UPDATE-EDIT) )
      (EDIT-STATUS)
      (IF *EDIT-MODE* (EDIT-TEXT))
      ((LAMBDA (*CURSOR-KEYS* *GLOBAL-DEMONS*)
	  (LOOP
	    (UPDATE-EDIT)
	    (EXECUTE-OPTION 'COMMAND *EDIT-OPTIONS*) ) )
	(IF *EMACS-KEYS* *EMACS-KEYS* *CURSOR-KEYS*)
	(IF *EMACS-KEYS* *EMACS-DEMONS* *GLOBAL-DEMONS*)) )
    (UPDATE-STATE '(*FILE-NAME* *SCREEN*
	    *FIND-STRG* *REPL-STRG* *EDIT-MODE* *TEXT-DIRTY*
	    *ABOVE-POINT* *BELOW-POINT* *POINT-LINE* *MARK-LIST*
	    *CURSOR-ROW* *CURSOR-COL* *POINT-ROW* *POINT-COL*)) ) )

(SETQ *EDIT-OPTIONS* '(
	("Alpha" . EDIT-TEXT)
	("Block" . EDIT-BLOCK)
	("Delete" . (
		("Block" . DELETE-BLOCK)
		("Character" . DELETE-RIGHT-CHAR)
		("Line" . DELETE-TEXT-LINE)
		("Right-end" . DELETE-RIGHT-END)
		("Word" . DELETE-RIGHT-WORD) ))
	("Jump" . (
		("Top" . JUMP-TOP-SCREEN)
		("Bottom" . JUMP-BOTTOM-SCREEN)
		("Start" . JUMP-START-TEXT)
		("End" . JUMP-END-TEXT)
		("Last" . JUMP-LAST-POSN) ))
	("List" . (
		("Back" . JUMP-LEFT-SEXP)
		("Delete" . DELETE-SEXP)
		("Eval" . EVAL-SEXP)
		("Forward" . JUMP-RIGHT-SEXP)
		("Next" . JUMP-NEXT-DEFN) ))
	("Mode" . SET-INSERT)
	("Options" . (
		("Color" . (
			("Menu" . SET-MENU-COLOR)
			("Work" . SET-WORK-COLOR) ))
		("Display" . SET-DISPLAY)
		("Execute" . GO-DOS)
		("Mute" . SET-MUTE) ))
	("Print" . (
		("Printer" . PRINT-FILE-PRINTER)
		("Layout" . PRINT-FILE-LAYOUT)
		("Options" . PRINT-FILE-OPTIONS) ))
	("Quit" . QUIT-PROGRAM)
	("Replace" . REPLACE-TEXT)
	("Search" . SEARCH-TEXT)
	("Transfer" . (
		("Save" . SAVE-TEXT-FILE)
		("Load" . LOAD-TEXT-FILE)
		("Merge" . MERGE-TEXT-FILE)
		("Clear" . CLEAR-TEXT-FILE)
		("Delete" . DELETE-TEXT-FILE) ))
	("Undelete" . UNDELETE-TEXT)
	("Window" . CHANGE-WINDOW) ))

(DEFUN EDIT-BLOCK ()
  (EXECUTE-OPTION 'BLOCK '(
	("Begin" . MARK-BLOCK-START)
	("End" . MARK-BLOCK-END)
	("Copy" . COPY-BLOCK)
	("Move" . MOVE-BLOCK)
	("Delete" . DELETE-BLOCK)
	("Jump" . (
		("Begin" . JUMP-BLOCK-START)
		("End" . JUMP-BLOCK-END) ))
	("Write" . WRITE-BLOCK) )) )

(DEFUN EDIT-TEXT (
    CHAR LST LINE *LOCAL-DEMONS* *UPDATE-FUNCTION* *CURSOR-ON*)
  (SETQ *EDIT-MODE* T
	*LOCAL-DEMONS* *EDIT-DEMONS*)
  (LOOP
    (SETQ *CURSOR-ON*)
    (CURSOR-OFF)
    ((LAMBDA (*OPTION-PROMPT* ROWS PROMPT INDENT) (SHOW-OPTIONS *EDIT-OPTIONS*))
	      'COMMAND)
    (SHOW-PROMPT "Edit text or press ESC for options")
    (SETQ *CURSOR-ON* T
	  LST)
    (UPDATE-EDIT)
    (CURRENT-WINDOW)
    (SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
    (LOOP
      (SETQ CHAR (READ-CONSOLE-BYTE))
      ((OR (< CHAR 32) (= CHAR 127)))
      (PUSH (WRITE-STRING (ASCII CHAR)) LST)
      ((>= (+ *CURSOR-COL* (LENGTH LST)) (WINDOW-COLS)))
      ((NOT (LISTEN))) )
    (SETQ LST (NREVERSE LST)
	  LINE (NTH *CURSOR-ROW* *SCREEN*)
	  LINE (PACK* (SUBSTRG LINE 0 *CURSOR-COL*)
		      (PACK (MAKE-LIST (- *CURSOR-COL* (STRING-LENGTH LINE))
				       " " LST))
		      (SUBSTRG LINE (+ *CURSOR-COL* (LENGTH LST)))))
    (REPLACE-NTH LINE *SCREEN* *CURSOR-ROW*)
    (ADD-TEXT-STRING (PACK LST) *INSERT-MODE*)
    (JUMP-TO-POSN *POINT-ROW* (+ *POINT-COL* (LENGTH LST)))
    (SETQ *FREE-LIST* (NCONC LST *FREE-LIST*))
    ((EQ CHAR 27))
    ( ((OR (< CHAR 32) (= CHAR 127))
	(DEMON-BYTE CHAR) ) ) )
  (SETQ *CURSOR-ON*)
  (CURSOR-OFF)
  (SETQ *EDIT-MODE*) )

(DEFUN CTRL-COMMAND (BYTE
    COMMANDS CHAR)
  (SETQ CHAR (ASCII (IF (< BYTE 32) (+ BYTE 64) BYTE))
	COMMANDS (EVAL (PACK* "*CTRL" CHAR "-DEMONS*"))
	CHAR (PROMPT-READ-BYTE
		(PACK* "Enter second char of Ctrl-" CHAR " command: ")))
  (IF (<= 97 CHAR 122) (DECQ CHAR 32) )
  (IF (< CHAR 32) (INCQ CHAR 64) )
  (SETQ BYTE (IF (<= 64 CHAR 90) (- CHAR 64) CHAR))
  ( ((EQ BYTE 32))
    ((SETQ BYTE (ASSOC BYTE COMMANDS))
      (WRITE-BYTE CHAR)
      (FUNCALL (CDR BYTE) (CAR BYTE)) )
    (ERROR-BEEP) ) )


;	* * *	Cursor line movement functions	 * * *

(DEFUN JUMP-UP-LINE ()
  ((ZEROP *POINT-ROW*))
  (JUMP-TO-POSN (SUB1 *POINT-ROW*) *POINT-COL*) )

(DEFUN JUMP-DOWN-LINE ()
  (JUMP-TO-POSN (ADD1 *POINT-ROW*) *POINT-COL*) )

(DEFUN JUMP-TOP-SCREEN ()
  (JUMP-TO-POSN (- *POINT-ROW* *CURSOR-ROW*) *POINT-COL*) )

(DEFUN JUMP-BOTTOM-SCREEN ()
  (JUMP-TO-POSN (+ *POINT-ROW* (- (WINDOW-ROWS) *CURSOR-ROW*) -2) *POINT-COL*) )

(DEFUN SCROLL-DOWN-LINE ()
  ((EQ *POINT-ROW* *CURSOR-ROW*))
  (SCROLL-SCREEN-DOWN 0)
  ((EQ *CURSOR-ROW* (- (WINDOW-ROWS) 2))
    (POINT-TO-POSN (SUB1 *POINT-ROW*) *POINT-COL*) )
  (INCQ *CURSOR-ROW*) )

(DEFUN SCROLL-UP-LINE ()
  (SCROLL-SCREEN-UP 0)
  ((ZEROP *CURSOR-ROW*)
    (POINT-TO-POSN (ADD1 *POINT-ROW*) *POINT-COL*) )
  (DECQ *CURSOR-ROW*) )

(DEFUN SCROLL-DOWN-SCREEN (
    NUM)
  ((< (SETQ NUM (- *POINT-ROW* (CEILING (* 4 (WINDOW-ROWS)) 5))) *CURSOR-ROW*)
    (JUMP-TO-POSN (MAX 0 NUM) *POINT-COL*) )
  (POINT-TO-POSN NUM *POINT-COL*) )

(DEFUN SCROLL-UP-SCREEN ()
  (POINT-TO-POSN (+ *POINT-ROW* (CEILING (* 4 (WINDOW-ROWS)) 5)) *POINT-COL*) )

(DEFUN JUMP-START-TEXT ()
  (JUMP-TO-POSN 0 0) )

(DEFUN JUMP-END-TEXT ()
  (JUMP-TO-POSN (+ *POINT-ROW* (ADD1 (LENGTH *BELOW-POINT*))) 0) )

(DEFUN DOWN-LINE-INDENT (
    COL NUM)
  (JUMP-TO-POSN (ADD1 *POINT-ROW*) 0)
  ((EQ *POINT-LINE* "")
    (SETQ COL 0)
    (LOOP
      ((EQ COL (STRING-LENGTH (CAR *ABOVE-POINT*)))
	(JUMP-TO-POSN *POINT-ROW* COL) )
      ((NON-WHITESPACEP (CHAR (CAR *ABOVE-POINT*) COL))
	(SETQ NUM COL)
	(LOOP
	  ( ((EQ (CHAR (CAR *ABOVE-POINT*) COL) *LPAR*)
	      (INCQ NUM 2) )
	    ((EQ (CHAR (CAR *ABOVE-POINT*) COL) *RPAR*)
	      (DECQ NUM 2) ) )
	  (INCQ COL)
	  ((EQ COL (STRING-LENGTH (CAR *ABOVE-POINT*)))
	    (JUMP-TO-POSN *POINT-ROW* NUM) ) ) )
      (INCQ COL) ) )
  (JUMP-WHITESPACE 0) )

(DEFUN JUMP-LAST-POSN ()
  (JUMP-TO-MARK *LAST-POSN*) )


;	* * *	Cursor column movement functions   * * *

(DEFUN JUMP-LEFT-CHAR ()
  ((ZEROP *POINT-COL*)
    ((ZEROP *POINT-ROW*))
    (JUMP-TO-POSN (SUB1 *POINT-ROW*) (STRING-LENGTH (CAR *ABOVE-POINT*))) )
  (JUMP-TO-POSN *POINT-ROW* (SUB1 *POINT-COL*)) )

(DEFUN JUMP-RIGHT-CHAR ()
  ((>= *POINT-COL* (STRING-LENGTH *POINT-LINE*))
    (JUMP-TO-POSN (ADD1 *POINT-ROW*) 0) )
  (JUMP-TO-POSN *POINT-ROW* (ADD1 *POINT-COL*)) )

(DEFUN JUMP-LEFT-END ()
  (JUMP-TO-POSN *POINT-ROW* 0) )

(DEFUN JUMP-RIGHT-END ()
  (JUMP-TO-POSN *POINT-ROW* (STRING-LENGTH *POINT-LINE*)) )

(DEFUN JUMP-LEFT-TAB ()
  ((ZEROP *POINT-COL*))
  (JUMP-TO-POSN *POINT-ROW* (* 8 (TRUNCATE (SUB1 *POINT-COL*) 8))) )

(DEFUN JUMP-LEFT-WORD (
    COL)
  ((ZEROP *POINT-COL*)
    (JUMP-LEFT-CHAR) )
  ((ZEROP (SETQ COL (MIN *POINT-COL* (STRING-LENGTH *POINT-LINE*))))
    (JUMP-LEFT-END) )
  (LOOP
    ((ZEROP (DECQ COL))
      (JUMP-TO-POSN *POINT-ROW* COL) )
    ((NON-WHITESPACEP (CHAR *POINT-LINE* COL))
      ((< COL (- *POINT-COL* 2))
	(JUMP-TO-POSN *POINT-ROW* (ADD1 COL)) )
      ((WORD-DELIMITERP (CHAR *POINT-LINE* COL))
	(JUMP-TO-POSN *POINT-ROW* COL) )
      (LOOP
	((ZEROP (DECQ COL))
	  (JUMP-TO-POSN *POINT-ROW* COL) )
	((WORD-DELIMITERP (CHAR *POINT-LINE* COL))
	  (JUMP-TO-POSN *POINT-ROW* (ADD1 COL)) ) ) ) ) )

(DEFUN JUMP-RIGHT-WORD (
    COL)
  ((>= *POINT-COL* (STRING-LENGTH *POINT-LINE*))
    (JUMP-TO-POSN (ADD1 *POINT-ROW*) 0)
    (JUMP-WHITESPACE 0) )
  (SETQ COL *POINT-COL*)
  (LOOP
    ((WORD-DELIMITERP (CHAR *POINT-LINE* COL))
      (JUMP-WHITESPACE (IF (EQ COL *POINT-COL*) (ADD1 COL) COL)) )
    ((>= (INCQ COL) (STRING-LENGTH *POINT-LINE*))
      (JUMP-TO-POSN *POINT-ROW* COL) ) ) )

(DEFUN JUMP-WHITESPACE (COL)
  (LOOP
    ((>= COL (STRING-LENGTH *POINT-LINE*))
      (JUMP-TO-POSN *POINT-ROW* COL) )
    ((NON-WHITESPACEP (CHAR *POINT-LINE* COL))
      (JUMP-TO-POSN *POINT-ROW* COL) )
    (INCQ COL) ) )


;	* * *	Text insertion functions   * * *

(DEFUN ADD-ESCAPE-CHAR (
    CHAR )
  ((MEMBER (SETQ CHAR (READ-CONSOLE-BYTE)) '(7 8 10 13)))
  ((MINUSP CHAR))
  (ADD-TEXT-STRING (ASCII CHAR) *INSERT-MODE*)
  (JUMP-TO-POSN *POINT-ROW* (ADD1 *POINT-COL*)) )

(DEFUN JUMP-RIGHT-TAB ()
  (LOOP
    ((OR *INSERT-MODE* (>= *POINT-COL* (STRING-LENGTH *POINT-LINE*)))
      (LOOP
	(ADD-TEXT-STRING " " T)
	(JUMP-TO-POSN *POINT-ROW* (ADD1 *POINT-COL*))
	((ZEROP (REM *POINT-COL* 8))) ) )
    (JUMP-TO-POSN *POINT-ROW* (ADD1 *POINT-COL*))
    ((ZEROP (REM *POINT-COL* 8))) ) )

(DEFUN ADD-TEXT-STRING (STRING MODE)
  ((EQ STRING ""))
  (SETQ *TEXT-DIRTY* T
	*POINT-LINE* (PACK*
	  (SUBSTRG *POINT-LINE* 0 *POINT-COL*)
	  (PACK (MAKE-LIST (- *POINT-COL* (STRING-LENGTH *POINT-LINE*)) " "))
	  STRING
	  (SUBSTRG *POINT-LINE*
		   (+ *POINT-COL* (IF MODE 0 (STRING-LENGTH STRING))))))
  ((NOT MODE))
  (ADJUST-COLS (STRING-LENGTH STRING)) )

(DEFUN ADD-NEWLINE ()
  (IF *INSERT-MODE* (INSERT-NEWLINE))
  (JUMP-TO-POSN (ADD1 *POINT-ROW*) 0) )

(DEFUN INSERT-NEWLINE ()
  (INSERT-TEXT (LIST "" "")) )


;	* * *	Text deletion functions   * * *

(DEFUN DELETE-RIGHT-CHAR ()
  ((>= *POINT-COL* (STRING-LENGTH *POINT-LINE*))
    (DELETE-NEWLINE) )
  (DELETE-TEXT-CHARS 1) )

(DEFUN DELETE-LEFT-CHAR ()
  ((ZEROP *POINT-COL*)
    ((ZEROP *POINT-ROW*))
    (JUMP-LEFT-CHAR)
    (DELETE-NEWLINE) )
  (JUMP-LEFT-CHAR)
  (DELETE-TEXT-CHARS 1) )

(DEFUN DELETE-RIGHT-END ()
  ((>= *POINT-COL* (STRING-LENGTH *POINT-LINE*))
    (DELETE-NEWLINE) )
  (DELETE-TEXT-CHARS (- (STRING-LENGTH *POINT-LINE*) *POINT-COL*)) )

(DEFUN DELETE-LEFT-END (
    COL)
  (SETQ COL *POINT-COL*)
  (JUMP-TO-POSN *POINT-ROW* 0)
  (DELETE-TEXT-CHARS COL) )

(DEFUN DELETE-RIGHT-WORD (
    NUM)
  ((>= *POINT-COL* (STRING-LENGTH *POINT-LINE*))
    (DELETE-NEWLINE) )
  (SETQ NUM 0)
  ((WHITESPACEP (CHAR *POINT-LINE* *POINT-COL*))
    (LOOP
      ((NON-WHITESPACEP (CHAR *POINT-LINE* (+ *POINT-COL* (INCQ NUM))))
	(DELETE-TEXT-CHARS NUM) ) ) )
  ((WORD-DELIMITERP (CHAR *POINT-LINE* *POINT-COL*))
    ((OR (ZEROP *POINT-COL*)
	 (WHITESPACEP (CHAR *POINT-LINE* (SUB1 *POINT-COL*))))
      (LOOP
	((NON-WHITESPACEP (CHAR *POINT-LINE* (+ *POINT-COL* (INCQ NUM))))
	  (DELETE-TEXT-CHARS NUM) ) ) )
    (DELETE-TEXT-CHARS 1) )
  (LOOP
    ((>= (+ *POINT-COL* (INCQ NUM)) (STRING-LENGTH *POINT-LINE*))
      (DELETE-TEXT-CHARS NUM) )
    ((WORD-DELIMITERP (CHAR *POINT-LINE* (+ *POINT-COL* NUM)))
      ((OR (ZEROP *POINT-COL*)
	   (WHITESPACEP (CHAR *POINT-LINE* (SUB1 *POINT-COL*))))
	(DECQ NUM)
	(LOOP
	  ((NON-WHITESPACEP (CHAR *POINT-LINE* (+ *POINT-COL* (INCQ NUM))))
	    (DELETE-TEXT-CHARS NUM) ) ) )
      (DELETE-TEXT-CHARS NUM) ) ) )

(DEFUN DELETE-LEFT-WORD ()
  ((AND (ZEROP *POINT-ROW*) (ZEROP *POINT-COL*)))
  (JUMP-LEFT-WORD)
  (DELETE-RIGHT-WORD) )

(DEFUN DELETE-TEXT-LINE (
    LINE)
  (JUMP-TO-POSN *POINT-ROW* 0)
  ((EQ (SETQ LINE (STRING-RIGHT-TRIM " " *POINT-LINE*)) "")
    (DELETE-NEWLINE) )
  (DELETE-TEXT-CHARS (STRING-LENGTH *POINT-LINE*))
  (SETQ *DELETED-TEXT* (LIST LINE ""))
  (DELETE-NEWLINE) )

(DEFUN DELETE-NEWLINE ()
  ((NULL *BELOW-POINT*))
  (ADD-TEXT-STRING (POP *BELOW-POINT*) T)
  (ADJUST-ROWS 1)
  (SCROLL-SCREEN-UP
	(IF (ZEROP *POINT-COL*) *CURSOR-ROW* (ADD1 *CURSOR-ROW*))) )

(DEFUN DELETE-TEXT-CHARS (NUM)
  ((ZEROP NUM) "")
  (SETQ *TEXT-DIRTY* T)
  (ADJUST-COLS (- NUM))
  (IF (> NUM 1)
      (SETQ *DELETED-TEXT* (LIST (SUBSTRG *POINT-LINE* *POINT-COL* NUM))) )
  (SETQ *POINT-LINE* (PACK* (SUBSTRG *POINT-LINE* 0 *POINT-COL*)
			    (SUBSTRG *POINT-LINE* (+ *POINT-COL* NUM)))) )


;	* * *	Search and replace functions   * * *

(DEFUN SEARCH-TEXT (
    TEXT )
  (SETQ TEXT (PROMPT-INPUT "Enter string to find" "String: " *FIND-STRG*))
  ((EQ *LINE-TERMINATOR* 27) NIL)
  (SETQ *FIND-STRG* TEXT
	*REPL-STRG* TEXT)
  (FIND-TEXT-STRING)
  0 )

(DEFUN REPLACE-TEXT (
    TEXT )
  (SETQ TEXT (PROMPT-INPUT "Enter string to replace" "String: " *FIND-STRG*))
  ((EQ *LINE-TERMINATOR* 27) NIL)
  (SETQ *FIND-STRG* TEXT
	TEXT (PROMPT-INPUT "Enter replacement string" "String: " *REPL-STRG*))
  ((EQ *LINE-TERMINATOR* 27) NIL)
  (SETQ *REPL-STRG* TEXT)
  (FIND-TEXT-STRING)
  0 )

(DEFUN REPEAT-REPLACE-TEXT ()
  (LOOP
    ((NULL (FIND-TEXT-STRING))) ) )

(DEFUN FIND-TEXT-STRING (
    TEXT ROW COL)
  (CURRENT-WINDOW)
  (SET-MARK *FIND-POSN*)
  ((SETQ COL (FINDSTRING (FIND-UPCASE *FIND-STRG*)
		(FIND-UPCASE (SUBSTRG *POINT-LINE* (ADD1 *POINT-COL*)))))
    (JUMP-TO-POSN *POINT-ROW* (+ *POINT-COL* COL 1))
    (REPLACE-TEXT-STRING) )
  (SETQ TEXT *BELOW-POINT*
	ROW *POINT-ROW*)
  (LOOP
    ((NULL TEXT)
      (JUMP-END-TEXT)
      NIL )
    (INCQ ROW)
    ((SETQ COL (FINDSTRING (FIND-UPCASE *FIND-STRG*)
			   (FIND-UPCASE (POP TEXT))))
      (JUMP-TO-POSN ROW COL)
      (REPLACE-TEXT-STRING) ) ) )

(DEFUN FIND-UPCASE (STRING)
  ((NOT *CASE-IGNORE*) STRING)
  (STRING-UPCASE STRING) )

(DEFUN REPLACE-TEXT-STRING (
    TEXTLINE CHAR *CURSOR-ON*)
  ((EQ *FIND-STRG* *REPL-STRG*) NIL)
  (SHOW-PROMPT "Replace string (Y/N)")
  (PROMPT-WINDOW)
  (SET-CURSOR 0 (LENGTH *PROMPT*))
  (BLINK-WRITE-STRING '?)
  (UPDATE-EDIT)
  (CURRENT-WINDOW)
  (SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
  (SETQ CHAR (READ-CONSOLE-BYTE))
  ((EQ CHAR 27) NIL)				;If ESC, return NIL
  ((MEMBER CHAR '(89 121 25))			;If Yes, replace
    (DELETE-TEXT-CHARS (STRING-LENGTH *FIND-STRG*))
    (ADD-TEXT-STRING *REPL-STRG* T)
    (JUMP-TO-POSN *POINT-ROW* (+ *POINT-COL* (STRING-LENGTH *REPL-STRG*))) )
  0 )

(DEFUN JUMP-LAST-SEARCH ()
  (JUMP-TO-MARK *FIND-POSN*) )


;	* * *	Block operation functions   * * *

(DEFUN MARK-BLOCK-START ()
  (SET-MARK *START-BLOCK*)
  ((OR (> (MARK-ROW *START-BLOCK*) (MARK-ROW *END-BLOCK*))
       (AND (= (MARK-ROW *START-BLOCK*) (MARK-ROW *END-BLOCK*))
	    (> (MARK-COL *START-BLOCK*) (MARK-COL *END-BLOCK*))))
    (SET-MARK *END-BLOCK*) )
  0 )

(DEFUN MARK-BLOCK-END ()
  (SET-MARK *END-BLOCK*)
  ((OR (> (MARK-ROW *START-BLOCK*) (MARK-ROW *END-BLOCK*))
       (AND (= (MARK-ROW *START-BLOCK*) (MARK-ROW *END-BLOCK*))
	    (> (MARK-COL *START-BLOCK*) (MARK-COL *END-BLOCK*))))
    (SET-MARK *START-BLOCK*) )
  0 )

(DEFUN JUMP-BLOCK-START ()
  (JUMP-TO-MARK *START-BLOCK*) )

(DEFUN JUMP-BLOCK-END ()
  (JUMP-TO-MARK *END-BLOCK*) )

(DEFUN WRITE-BLOCK (
    FILE-NAME TEXT)
  (SETQ FILE-NAME "")
  (LOOP
    (SETQ FILE-NAME (PROMPT-TEXT-FILE FILE-NAME *DEFAULT-TYPE*))
    ((EQ FILE-NAME "") NIL)
    ((AND (OR (NOT (PROBE-FILE FILE-NAME))
	      (PROMPT-YN "Overwrite existing file") )
	  (OPEN-OUTPUT-FILE FILE-NAME))
      (SETQ TEXT (GET-BLOCK))
      (POINT-TO-MARK *TEMP-POSN*)
      (IF (EQ (CAR (LAST TEXT)) "")
	  (SETQ TEXT (NBUTLAST TEXT)) )
      (WRITE-TEXT-FILE TEXT)
      0 )
    (ERROR-BEEP) ) )

(DEFUN MERGE-TEXT-FILE (
    FILE-NAME *SCROLL-FLAG*)
  (SETQ FILE-NAME "")
  (LOOP
    (SETQ FILE-NAME (PROMPT-TEXT-FILE FILE-NAME *DEFAULT-TYPE*))
    ((EQ FILE-NAME "") NIL)
    ((OPEN-INPUT-FILE FILE-NAME)
      (INSERT-TEXT (NCONC (READ-TEXT-FILE) (LIST "")))
      0 )
    (ERROR-BEEP) ) )

(DEFUN UNDELETE-TEXT ()
  (SET-MARK *TEMP-POSN*)
  (INSERT-TEXT (COPY-LIST *DELETED-TEXT*))
  (JUMP-TO-MARK *TEMP-POSN*) )

(DEFUN MOVE-BLOCK (
    ROW COL)
  (SETQ ROW (- (MARK-ROW *END-BLOCK*) (MARK-ROW *START-BLOCK*))
	COL (- (MARK-COL *END-BLOCK*)
	       (IF (ZEROP ROW) (MARK-COL *START-BLOCK*) 0)) )
  (INSERT-TEXT (COPY-LIST (DELETE-BLOCK)))
  (MARK-BLOCK-START)
  (SET-MARK *END-BLOCK* (+ *POINT-ROW* ROW)
			(IF (ZEROP ROW) (+ *POINT-COL* COL) COL)) )

(DEFUN COPY-BLOCK ()
  (INSERT-TEXT (COPY-LIST (GET-BLOCK)) (POINT-TO-MARK *TEMP-POSN*)) )

(DEFUN DELETE-BLOCK (
    TEXT *SCROLL-FLAG*)
  ( ((PAST-POINT (NTH *START-BLOCK* *MARK-LIST*)))
    ((PAST-POINT (NTH *END-BLOCK* *MARK-LIST*))
      (JUMP-BLOCK-START) ) )
  (SETQ TEXT (GET-BLOCK))
  ( ((NULL TEXT))
    ((EQUAL TEXT '("")))
    ( ((EQ (MARK-ROW *START-BLOCK*) (MARK-ROW *END-BLOCK*)))
      (DELETE-TEXT-CHARS (- (STRING-LENGTH *POINT-LINE*) *POINT-COL*))
      (SETQ *BELOW-POINT* (NTHCDR (- (MARK-ROW *END-BLOCK*)
				     (MARK-ROW *START-BLOCK*) 1)
				  *BELOW-POINT*))
      (ADJUST-ROWS (- (MARK-ROW *END-BLOCK*) (MARK-ROW *START-BLOCK*) 1))
      (DELETE-RIGHT-CHAR) )
    ( ((>= (MARK-COL *START-BLOCK*) (MARK-COL *END-BLOCK*)))
      (DELETE-TEXT-CHARS (- (MARK-COL *END-BLOCK*) (MARK-COL *START-BLOCK*))) )
    (SETQ *DELETED-TEXT* TEXT) )
  (POINT-TO-MARK *TEMP-POSN*)
  TEXT )

(DEFUN GET-BLOCK (			;Get current block of text
    TEXT)
  (SET-MARK *TEMP-POSN*)
  (POINT-TO-MARK *START-BLOCK*)
  ((SETQ TEXT (CONS *POINT-LINE*
		(FIRSTN (- (MARK-ROW *END-BLOCK*) (MARK-ROW *START-BLOCK*))
			*BELOW-POINT*)))
    ( ((< (LENGTH TEXT) (- (MARK-ROW *END-BLOCK*) (MARK-ROW *START-BLOCK*) -1))
	(NCONC TEXT (LIST "")) ) )
    (RPLACA (LAST TEXT) (SUBSTRG (CAR (LAST TEXT)) 0 (MARK-COL *END-BLOCK*)))
    (RPLACA TEXT (SUBSTRG (CAR TEXT) (MARK-COL *START-BLOCK*))) ) )

(DEFUN INSERT-TEXT (TEXT		;Insert text at point
    ROWS)				;WARNING: modifies text
  ((NULL TEXT))
  ((EQ TEXT '("")))
  (SETQ *TEXT-DIRTY* T
	ROWS (LENGTH TEXT))
  (ADD-TEXT-STRING (CAR (LAST TEXT)) T)
  (SETQ *BELOW-POINT* (NCONC (NBUTLAST TEXT) (CONS
		(STRING-RIGHT-TRIM " " (SUBSTRG *POINT-LINE* *POINT-COL*))
		*BELOW-POINT*))
	*POINT-LINE* (SUBSTRG *POINT-LINE* 0 *POINT-COL*))
  (MAPC '(LAMBDA (PAIR)
	  ((PAST-POINT PAIR)
	    (RPLACA PAIR (+ (CAR PAIR) ROWS)) ) )
	*MARK-LIST*)
  (MAPC '(LAMBDA (PAIR)
	  ((AND (= (CAR PAIR) (+ *POINT-ROW* ROWS))
		(>= (CDR PAIR) *POINT-COL*))
	    (RPLACD PAIR (- (CDR PAIR) *POINT-COL*)) ) )
	*MARK-LIST*)
  (ADD-TEXT-STRING (POP *BELOW-POINT*) T)
  (ADJUST-ROWS 1)
  (IF (EQ ROWS 2)
      (SCROLL-SCREEN-DOWN (IF (ZEROP *POINT-COL*)
			      *CURSOR-ROW* (ADD1 *CURSOR-ROW*))) )
  0 )


;	* * *	LISP movement functions   * * *

(SETQ *SINGLE-ESCAPE* '\\ )
(SETQ *MULTIPLE-ESCAPE* '\| )

(DEFUN JUMP-LEFT-SEXP ( 	;Move cursor left S-expression
    CHAR LINE TEXT ROW COL )
  (SETQ LINE *POINT-LINE*
	TEXT *ABOVE-POINT*
	ROW *POINT-ROW*
	COL (MIN *POINT-COL* (FIND-COMMENT LINE)))
  (LOOP
    ((NULL (SETQ CHAR (GET-LAST-CHAR)))
      (JUMP-TO-POSN 0 0) )
    ((EQ CHAR *LPAR*)
      (JUMP-TO-POSN ROW COL) )
    ((EQ CHAR *RPAR*)
      ((FIND-MATCHING-LPAR 1)
	(JUMP-TO-POSN ROW COL) )
      (JUMP-TO-POSN 0 0) )
    ((NON-WHITESPACEP CHAR)
      (LOOP
	((ZEROP COL)
	  (JUMP-TO-POSN ROW COL) )
	(SETQ CHAR (GET-LAST-CHAR))
	((OR (EQ CHAR *LPAR*) (EQ CHAR *RPAR*) (WHITESPACEP CHAR))
	  (JUMP-TO-POSN ROW (ADD1 COL)) ) ) ) ) )

(DEFUN FIND-MATCHING-LPAR (NUM LISTEN
    CHAR )
  (LOOP
    ((NULL (SETQ CHAR (GET-LAST-CHAR))) NIL)
    ( ((EQ *SINGLE-ESCAPE* (CHAR LINE (SUB1 COL))))
      ((EQ CHAR *LPAR*)
	(DECQ NUM) )
      ((EQ CHAR *RPAR*)
	(INCQ NUM) )
      ((EQ CHAR *MULTIPLE-ESCAPE*)
	(LOOP
	  ((AND LISTEN (LISTEN)))
	  ((NULL (SETQ CHAR (GET-LAST-CHAR))))
	  ((AND (EQ CHAR *MULTIPLE-ESCAPE*)
		(NEQ *SINGLE-ESCAPE* (CHAR LINE (SUB1 COL))))) ) )
      ((EQ CHAR '\")
	(LOOP
	  ((AND LISTEN (LISTEN)))
	  ((NULL (SETQ CHAR (GET-LAST-CHAR))))
	  ((AND (EQ CHAR '\")
		(NEQ *SINGLE-ESCAPE* (CHAR LINE (SUB1 COL))))) ) ) )
    ((NULL CHAR) NIL)
    ((ZEROP NUM))
    ((AND LISTEN (LISTEN)) NIL) ) )

(DEFUN LAST-NONWS (		;Last non-whitespace char & PREDICATE
    CHAR)
  (LOOP
    ((NULL (SETQ CHAR (GET-LAST-CHAR))) NIL)
    ((NON-WHITESPACEP CHAR) CHAR) ) )

(DEFUN GET-LAST-CHAR () 	;Get last character & PREDICATE
  (LOOP
    ((PLUSP COL)
      ((CHAR LINE (DECQ COL)))
      (GET-LAST-CHAR) )
    ((NULL TEXT) NIL)
    ((MINUSP (DECQ ROW)) NIL)
    (SETQ LINE (POP TEXT)
	  COL (FIND-COMMENT LINE)) ) )

(DEFUN FIND-COMMENT (LINE
    NUM)
  (SETQ NUM 0)
  (LOOP
    ((NULL (SETQ NUM (FINDSTRING '\; LINE NUM)))
      (STRING-LENGTH LINE) )
    ((NEQ (CHAR LINE (SUB1 NUM)) '\\ ) NUM)
    (INCQ NUM) ) )

(DEFUN JUMP-RIGHT-SEXP (	;Move cursor right S-expression
    CHAR LINE TEXT ROW COL )
  (SETQ LINE *POINT-LINE*
	TEXT *BELOW-POINT*
	ROW *POINT-ROW*
	COL *POINT-COL*)
  ( ((SETQ CHAR (NEXT-NONWS))
      ((EQ CHAR *RPAR*)
	(NEXT-NONWS) )
      ((EQ CHAR *LPAR*)
	((FIND-MATCHING-RPAR 1)
	  (NEXT-NONWS) ) )
      (LOOP
	((NULL (CHAR LINE COL))
	  (INCQ COL) )
	(SETQ CHAR (GET-NEXT-CHAR))
	((OR (EQ CHAR *LPAR*) (EQ CHAR *RPAR*)))
	((WHITESPACEP CHAR)
	  (NEXT-NONWS) ) ) ) )
  (JUMP-TO-POSN ROW (SUB1 COL)) )

(DEFUN FIND-MATCHING-RPAR (NUM LISTEN
    CHAR )
  (LOOP
    ((AND LISTEN (LISTEN)) NIL)
    ((NULL (SETQ CHAR (NEXT-NONWS))) NIL)
    ( ((EQ CHAR *RPAR*)
	(DECQ NUM) )
      ((EQ CHAR *LPAR*)
	(INCQ NUM) )
      ((EQ CHAR *SINGLE-ESCAPE*)
	(SETQ CHAR (GET-NEXT-CHAR)) )
      ((EQ CHAR *MULTIPLE-ESCAPE*)
	(LOOP
	  ((AND LISTEN (LISTEN)))
	  ((NULL (SETQ CHAR (GET-NEXT-CHAR))))
	  ((EQ CHAR *MULTIPLE-ESCAPE*))
	  (IF (EQ CHAR *SINGLE-ESCAPE*) (GET-NEXT-CHAR)) ) )
      ((EQ CHAR '\")
	(LOOP
	  ((AND LISTEN (LISTEN)))
	  ((NULL (SETQ CHAR (GET-NEXT-CHAR))))
	  ((EQ CHAR '\"))
	  (IF (EQ CHAR *SINGLE-ESCAPE*) (GET-NEXT-CHAR)) ) ) )
    ((NULL CHAR) NIL)
    ((AND LISTEN (>= ROW (WINDOW-ROWS))) NIL)
    ((ZEROP NUM)) ) )

(DEFUN NEXT-NONWS (		;Next non-whitespace/non-comment char
    CHAR )			;& PREDICATE
  (LOOP
    (LOOP
      (SETQ CHAR (GET-NEXT-CHAR))
      ((NEQ CHAR '\;))
      (INCQ ROW)
      (SETQ LINE (IF TEXT (POP TEXT) "")
	    COL 0) )
    ((OR (NULL CHAR) (NON-WHITESPACEP CHAR)) CHAR) ) )

(DEFUN GET-NEXT-CHAR () 	;Get next character & PREDICATE
  (LOOP
    ((CHAR LINE COL (INCQ COL)))
    ((NULL TEXT) NIL)
    (INCQ ROW)
    (SETQ LINE (POP TEXT)
	  COL 0) ) )


(DEFUN JUMP-THIS-DEFN ( 	;Move cursor back to defun
    LINE ROW )
  (SETQ LINE *POINT-LINE*
	ROW 0)
  (LOOP
    ((AND (OR (NEQ ROW 0) (NEQ *POINT-COL* 0))
	  (NEQ LINE "")
	  (NEQ (CHAR LINE 0) '\;)
	  (NON-WHITESPACEP (CHAR LINE 0))))
    ((EQ ROW *POINT-ROW*))
    (SETQ LINE (NTH ROW *ABOVE-POINT*))
    (INCQ ROW) )
  (JUMP-TO-POSN (- *POINT-ROW* ROW) 0) )

(DEFUN JUMP-NEXT-DEFN ( 	;Move cursor forward to defun
    LINE ROW )
  ((NULL *BELOW-POINT*))
  (SETQ ROW 0)
  (LOOP
    (SETQ LINE (NTH ROW *BELOW-POINT*))
    (INCQ ROW)
    ((AND (NEQ LINE "")
	  (NEQ (CHAR LINE 0) '\;)
	  (NON-WHITESPACEP (CHAR LINE 0))))
    ((EQ ROW (LENGTH *BELOW-POINT*))) )
  (JUMP-TO-POSN (+ *POINT-ROW* ROW) 0) )

(DEFUN DELETE-SEXP (		;Delete S-expression
    *CURSOR-ROW* *CURSOR-COL* *SCROLL-FLAG*)
  (SETQ *CURSOR-ROW* 0
	*CURSOR-COL* 0)
  (MARK-BLOCK-START)
  (JUMP-RIGHT-SEXP)
  (MARK-BLOCK-END)
  (DELETE-BLOCK) )

(DEFUN EVAL-SEXP (				;Eval S-expression
    WINDOW *STRING-INDEX* *READ-STRINGS*)
  (SETQ WINDOW 0)
  (LOOP
    ((EQ WINDOW (LENGTH *WINDOWS*))
      (SHOW-PROMPT "Press ESC to abort")
      (OPTION-WINDOW 0)
      ((LAMBDA (*INTERRUPT-HOOK*) (CATCH NIL
	(EVAL (READ-FROM-STRING
		(CONS (SUBSTRG *POINT-LINE* *POINT-COL*) *BELOW-POINT*)
		T)))) 'THROW) )
    ((EQ (CAR (WINDOW-STATE WINDOW)) "Debug")
      ((LAMBDA (*CURRENT-WINDOW*)
	  (APPLY "Debug" 'DISPLAY NIL
	     (READ-FROM-STRING
		(CONS (SUBSTRG *POINT-LINE* *POINT-COL*) *BELOW-POINT*) T)
	     (NTHCDR 3 (WINDOW-STATE))) )
	WINDOW) )
    (INCQ WINDOW) )
  (JUMP-RIGHT-SEXP) )


;	* * *	Cursor movement primitives   * * *

(DEFUN JUMP-TO-MARK (MARK)
  (JUMP-TO-POSN (MARK-ROW MARK) (MARK-COL MARK)) )

(DEFUN JUMP-TO-POSN (ROW COL		;Move cursor & point to ROW and COL
    TOP-ROW)				;Returns a nonNIL value
  (SETQ ROW (MAX 0 ROW)
	COL (MAX 0 COL))
  ( ((EQ ROW *POINT-ROW*))
    (SETQ TOP-ROW (- *POINT-ROW* *CURSOR-ROW*))
    ((< ROW TOP-ROW)
      ((>= ROW (- TOP-ROW (TRUNCATE (WINDOW-ROWS) 4)))
	(SETQ *CURSOR-ROW* 0
	      TOP-ROW (- TOP-ROW ROW))
	(LOOP
	  (SCROLL-SCREEN-DOWN 0)
	  ((ZEROP (DECQ TOP-ROW))) ) )
      (SETQ *CURSOR-ROW* (TRUNCATE (WINDOW-ROWS) 2)) )
    ((<= ROW (+ TOP-ROW (WINDOW-ROWS) -2))
      (SETQ *CURSOR-ROW* (- ROW TOP-ROW)) )
    ((<= ROW (+ TOP-ROW (WINDOW-ROWS) (TRUNCATE (WINDOW-ROWS) 4)))
      (SETQ *CURSOR-ROW* (- (WINDOW-ROWS) 2)
	    TOP-ROW (- ROW *CURSOR-ROW* TOP-ROW))
      (LOOP
	(SCROLL-SCREEN-UP 0)
	((ZEROP (DECQ TOP-ROW))) ) )
    (SETQ *CURSOR-ROW* (TRUNCATE (WINDOW-ROWS) 2)) )
  ( ((> *CURSOR-ROW* ROW)
      (SETQ *CURSOR-ROW* ROW) ) )
  ( ((EQ COL *POINT-COL*))
    ((< COL (- *POINT-COL* *CURSOR-COL*))
      (SETQ *CURSOR-COL* (TRUNCATE (WINDOW-COLS) 4)) )
    ((>= COL (+ (- *POINT-COL* *CURSOR-COL*) (WINDOW-COLS)))
      (SETQ *CURSOR-COL* (TRUNCATE (* 3 (WINDOW-COLS)) 4)) )
    (SETQ *CURSOR-COL* (+ *CURSOR-COL* (- COL *POINT-COL*))) )
  ( ((> *CURSOR-COL* COL)
      (SETQ *CURSOR-COL* COL) ) )
  (POINT-TO-POSN ROW COL)
  0 )


(DEFUN POINT-TO-MARK (MARK)
  (POINT-TO-POSN (MARK-ROW MARK) (MARK-COL MARK)) )

(DEFUN POINT-TO-POSN (ROW COL		;Move point to ROW and COL
    LST1 LST2)
  (IF (AND *SCROLL-FLAG*
	   (OR (/= ROW *POINT-ROW*) (>= (ABS (- COL *POINT-COL*)) 2)))
      (SET-MARK *LAST-POSN*) )
  (SETQ *POINT-COL* COL)
  ((EQ ROW *POINT-ROW*))
  (PUSH (STRING-RIGHT-TRIM " " *POINT-LINE*) *BELOW-POINT*)
  ((< *POINT-ROW* ROW)
    (SETQ LST1 *BELOW-POINT*
	  LST2 (NTHCDR (- ROW *POINT-ROW* 1) LST1))
    ((NULL LST2)
      (SETQ *ABOVE-POINT* (MAKE-LIST (- ROW *POINT-ROW* (LENGTH *BELOW-POINT*))
				     ""
				     (NREVERSE *BELOW-POINT* *ABOVE-POINT*))
	    *POINT-ROW* ROW
	    *POINT-LINE* ""
	    *BELOW-POINT*) )
    (SETQ *BELOW-POINT* (CDR LST2))
    (RPLACD LST2)
    (SETQ *ABOVE-POINT* (NREVERSE LST1 *ABOVE-POINT*)
	  *POINT-ROW* ROW
	  *POINT-LINE* (IF *BELOW-POINT* (POP *BELOW-POINT*) "")) )
  (SETQ LST1 *ABOVE-POINT*
	LST2 (NTHCDR (- *POINT-ROW* ROW 1) LST1)
	*ABOVE-POINT* (CDR LST2))
  (RPLACD LST2)
  (SETQ *BELOW-POINT* (TRIM-TEXT (NREVERSE LST1 *BELOW-POINT*))
	*POINT-ROW* ROW
	*POINT-LINE* (IF *BELOW-POINT* (POP *BELOW-POINT*) "")) )

(DEFUN SCROLL-SCREEN-UP (ROW)
  (CURRENT-WINDOW)
  ((AND *SCROLL-FLAG* (SET-CURSOR ROW 0) (DELETE-LINES 1))
    (SETQ *SCREEN* (DELETE-NTH (NCONC *SCREEN* (CONS "")) ROW)) ) )

(DEFUN SCROLL-SCREEN-DOWN (ROW)
  (CURRENT-WINDOW)
  ((AND *SCROLL-FLAG* (SET-CURSOR ROW 0) (INSERT-LINES 1))
    (SETQ *SCREEN* (NBUTLAST (INSERT-NTH "" *SCREEN* ROW))) ) )

(DEFUN ADJUST-ROWS (ROWS)
  (MAPC '(LAMBDA (PAIR)
	  ((PAST-POINT PAIR)
	    ((= (CAR PAIR) (+ *POINT-ROW* ROWS))
	      (RPLACA PAIR *POINT-ROW*)
	      (RPLACD PAIR (+ (CDR PAIR) *POINT-COL*)) )
	    ((< (CAR PAIR) (+ *POINT-ROW* ROWS))
	      (RPLACA PAIR *POINT-ROW*)
	      (RPLACD PAIR *POINT-COL*) )
	    (RPLACA PAIR (- (CAR PAIR) ROWS)) ) )
	*MARK-LIST*) )

(DEFUN ADJUST-COLS (COLS)
  (MAPC '(LAMBDA (PAIR)
	  ((AND (= (CAR PAIR) *POINT-ROW*)
		(>= (CDR PAIR) *POINT-COL*))
	    (RPLACD PAIR (MAX *POINT-COL* (+ (CDR PAIR) COLS))) ) )
	*MARK-LIST*) )

(DEFUN PAST-POINT (PAIR)
  ((> (CAR PAIR) *POINT-ROW*))
  (AND (= (CAR PAIR) *POINT-ROW*) (>= (CDR PAIR) *POINT-COL*)) )


;		* * *	Screen update functions   * * *

(DEFUN UPDATE-EDIT (
    LINE TEXT ROW COL ROW1 COL1 COL2)
  ((LISTEN))
  (SETQ *CURSOR-ROW* (MIN *CURSOR-ROW* *POINT-ROW*)
	*CURSOR-COL* (MIN *CURSOR-COL* *POINT-COL*)
	ROW 0
	COL (- *POINT-COL* *CURSOR-COL*))
  (UPDATE-EDIT-LINE (SUBSTRG *POINT-LINE* COL) *CURSOR-ROW*)
  (LOOP 				;Update lines below point
    ((LISTEN)
      (RETURN) )
    (INCQ ROW)
    ((AND (> ROW *CURSOR-ROW*) (>= (+ *CURSOR-ROW* ROW) (WINDOW-ROWS))))
    ( ((>= (+ *CURSOR-ROW* ROW) (WINDOW-ROWS)))
      (UPDATE-EDIT-LINE (SUBSTRG
		(CAR (OR (NTHCDR (SUB1 ROW) *BELOW-POINT*) '(""))) COL)
			(+ *CURSOR-ROW* ROW)) )
    ( ((> ROW *CURSOR-ROW*))
      (UPDATE-EDIT-LINE (SUBSTRG (NTH (SUB1 ROW) *ABOVE-POINT*) COL)
			(- *CURSOR-ROW* ROW)) ) )
  ((NOT *EDIT-STATUS*))
  ( ((AND (EQ *STAT-ROW* *POINT-ROW*) (EQ *STAT-COL* *POINT-COL*)))
    ((SMALL-SCREENP))
    (STATUS-WINDOW)
    (SET-CURSOR 0 35)
    (PRIN1 (ADD1 *POINT-ROW*))
    (SPACES (- (PRINT-LENGTH (ADD1 *STAT-ROW*))
	       (PRINT-LENGTH (ADD1 *POINT-ROW*))))
    (SET-CURSOR 0 45)
    (PRIN1 (ADD1 *POINT-COL*))
    (SPACES (- (PRINT-LENGTH (ADD1 *STAT-COL*))
	       (PRINT-LENGTH (ADD1 *POINT-COL*))))
    (SETQ *STAT-ROW* *POINT-ROW*
	  *STAT-COL* *POINT-COL*) )
  ((NOT *CURSOR-ON*))
  (CURRENT-WINDOW)
  (SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
  (CURSOR-ON)
  (SETQ LINE *POINT-LINE*
	TEXT *BELOW-POINT*
	ROW *CURSOR-ROW*
	COL *POINT-COL*)
  ( ((OR (EQ (GET-NEXT-CHAR) *LPAR*) (EQ (NEXT-NONWS) *LPAR*))
      ((FIND-MATCHING-RPAR 1 T)
	(DECQ COL)
	(SETQ ROW1 ROW
	      COL1 (BLINK-TEXT-CHAR *RPAR*)) ) ) )
  (SETQ LINE *POINT-LINE*
	TEXT *ABOVE-POINT*
	ROW *CURSOR-ROW*
	COL *POINT-COL*)
  ( ((OR (EQ (CHAR LINE COL) *RPAR*) (EQ (LAST-NONWS) *RPAR*))
      ((FIND-MATCHING-LPAR 1 T)
	(SETQ COL2 (BLINK-TEXT-CHAR *LPAR*)) ) ) )
  (READ-BYTE)
  (UNREAD-CHAR)
  ( ((NULL COL1))
    (SET-CURSOR ROW1 COL1)
    (WRITE-STRING *RPAR*) )
  ((NULL COL2))
  (SET-CURSOR ROW COL2)
  (WRITE-STRING *LPAR*) )

(DEFUN UPDATE-EDIT-LINE (LINE ROW
    COL SCREEN)
  ((EQ (SETQ SCREEN (NTH ROW *SCREEN*)) LINE))
  (REPLACE-NTH LINE *SCREEN* ROW)
  ((SETQ COL (STRING/= SCREEN LINE))
    ((>= COL (WINDOW-COLS)))
    (CURRENT-WINDOW)
    (SET-CURSOR ROW COL)
    (SPACES (- (MIN (WINDOW-COLS) (STRING-LENGTH SCREEN)) COL
	       (STRING-LENGTH (WRITE-STRING (SUBSTRG LINE COL
			      (- (WINDOW-COLS) COL)))))) ) )

(DEFUN BLINK-TEXT-CHAR (CHAR)
  (SETQ COL (- COL (- *POINT-COL* *CURSOR-COL*)))
  ((< -1 COL (WINDOW-COLS))
    (SET-CURSOR ROW COL)
    (BLINK-WRITE-STRING CHAR)
    (SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
    COL ) )

;		* * *	File I/O operation functions   * * *

(DEFUN SAVE-TEXT-FILE (
    FILE-NAME NUM LINE)
  (SETQ FILE-NAME *FILE-NAME*)
  (LOOP
    (SETQ FILE-NAME (PROMPT-TEXT-FILE FILE-NAME *DEFAULT-TYPE*))
    ((EQ FILE-NAME "") NIL)
    ((AND (OR (EQ FILE-NAME *FILE-NAME*)
	      (NOT (PROBE-FILE FILE-NAME))
	      (PROMPT-YN "Overwrite existing file") )
	  (OPEN-OUTPUT-FILE FILE-NAME))
      (SETQ NUM (LENGTH *ABOVE-POINT*)
	    LINE (STRING-RIGHT-TRIM " " *POINT-LINE*)
	    *BELOW-POINT* (TRIM-TEXT *BELOW-POINT*)
	    *ABOVE-POINT* (NREVERSE *ABOVE-POINT*
				    (IF (OR *BELOW-POINT* (NEQ LINE ""))
					(CONS LINE *BELOW-POINT*)))
	    *FILE-NAME* (NORMALIZE-FILE-NAME (OUTPUT-FILE))
	    *OUTPUT-FILE*)
      (EDIT-STATUS)
      (UNWIND-PROTECT
	(WRITE-TEXT-FILE *ABOVE-POINT*)
	((ZEROP NUM)
	  (SETQ *ABOVE-POINT*) )
	(RPLACD (NTHCDR (SUB1 NUM) *ABOVE-POINT*))
	(SETQ *ABOVE-POINT* (NREVERSE *ABOVE-POINT*)) )
      (SETQ *TEXT-DIRTY*)
      0 )
    (ERROR-BEEP) ) )

(DEFUN CLEAR-TEXT-FILE ()
  ((ABANDON-TEXT-FILE)
    (SETQ *FILE-NAME* "")
    (CURRENT-WINDOW T)
    (SETQ *SCREEN* (MAKE-LIST (WINDOW-ROWS) "")
	  *UNPACKED* NIL
	  *TEXT-DIRTY* NIL
	  *ABOVE-POINT* NIL
	  *BELOW-POINT* NIL
	  *POINT-LINE* ""
	  *MARK-LIST* (COPY-TREE (MAKE-LIST 9 (CONS 0 0)))
	  *CURSOR-ROW* 0
	  *CURSOR-COL* 0
	  *POINT-ROW* 0
	  *POINT-COL* 0)
    (EDIT-STATUS)
    0 ) )

(DEFUN ABANDON-TEXT-FILE ()
  ((NOT *TEXT-DIRTY*))
  ((EQ *FILE-NAME* "")
    (PROMPT-YN "Abandon edited text") )
  (PROMPT-YN (PACK* "Abandon edited " *FILE-NAME*)) )

(DEFUN DELETE-TEXT-FILE (
    FILE-NAME)
  (SETQ FILE-NAME "")
  (LOOP
    (SETQ FILE-NAME (PROMPT-TEXT-FILE FILE-NAME))
    ((EQ FILE-NAME "") NIL)
    ((AND (NOT (OR (INPUT-FILE-P FILE-NAME) (OUTPUT-FILE-P FILE-NAME)))
	  (DELETE-FILE FILE-NAME)))
    (ERROR-BEEP) ) )

(DEFUN LOAD-TEXT-FILE (
    FILE-NAME)
  (SETQ FILE-NAME *FILE-NAME*)
  (LOOP
    (SETQ FILE-NAME (PROMPT-TEXT-FILE FILE-NAME *DEFAULT-TYPE*))
    ((EQ FILE-NAME "") NIL)
    ((PROBE-FILE FILE-NAME)
      ((CLEAR-TEXT-FILE)
	(OPEN-INPUT-FILE FILE-NAME)
	(SETQ *FILE-NAME* (NORMALIZE-FILE-NAME (INPUT-FILE)))
	(EDIT-STATUS)
	(SETQ *BELOW-POINT* (READ-TEXT-FILE)
	      *POINT-LINE* (IF *BELOW-POINT* (POP *BELOW-POINT*) ""))
	0 ) )
    (ERROR-BEEP) ) )

(DEFUN READ-TEXT-FILE (
    LST *TAB-EXPAND* *INPUT-ECHO*)
  (SHOW-PROMPT "Reading file...")
  (SETQ *TAB-EXPAND* T)
  (LOOP
    ((NOT (LISTEN)))
    (PUSH (STRING-RIGHT-TRIM " " (READ-LINE)) LST) )
  (CLOSE-INPUT-FILE)
  (NREVERSE LST) )

(DEFUN WRITE-TEXT-FILE (TEXT
    *BLANK-COMPRESS* *OUTPUT-ECHO*)
  (SHOW-PROMPT "Saving file...")
  (SETQ *OUTPUT-FILE* T
	*BLANK-COMPRESS* *USE-TABS*)
  ((CATCH "Disk Full"
      (MAPC 'WRITE-LINE TEXT)
      (WRITE-BYTE 26)
      (CLOSE-OUTPUT-FILE)) )
  (FILE-WRITE-POSITION 0)
  (CLOSE-OUTPUT-FILE)
  (ERROR-MESSAGE "Disk full; delete some files and retry") )


;		* * *	Print file functions   * * *

(SETQ *PAGE-LINES* 66)			;Page length in lines
(SETQ *PAGE-COLUMNS* 80)		;Page width in character columns
(SETQ *TOP-MARGIN* 0)			;Top margin in lines
(SETQ *BOTTOM-MARGIN* 8)		;Bottom margin in lines
(SETQ *LEFT-MARGIN* 5)			;Left margin in character columns
(SETQ *RIGHT-MARGIN* 0) 		;Right margin in character columns
(SETQ *FOOTER-MARGIN* 6)		;Footer margin in character columns

(DEFUN PRINT-FILE-LAYOUT (
    NUM1 NUM2 NUM3 NUM4 NUM5 NUM6)
  (RPLACA (CAR PRINT-FILE-LAYOUT) *PAGE-LINES*)
  (RPLACA (CADR PRINT-FILE-LAYOUT) *PAGE-COLUMNS*)
  (RPLACA (CADDR PRINT-FILE-LAYOUT) *TOP-MARGIN*)
  (RPLACA (CADDDR PRINT-FILE-LAYOUT) *BOTTOM-MARGIN*)
  (RPLACA (FIFTH PRINT-FILE-LAYOUT) *LEFT-MARGIN*)
  (RPLACA (SIXTH PRINT-FILE-LAYOUT) *RIGHT-MARGIN*)
  (LOOP
    ((NOT (MODE-QUERY PRINT-FILE-LAYOUT)))
    (SETQ NUM1 (PARSE-INTEGER-CAR (CAR PRINT-FILE-LAYOUT))
	  NUM2 (PARSE-INTEGER-CAR (CADR PRINT-FILE-LAYOUT))
	  NUM3 (PARSE-INTEGER-CAR (CADDR PRINT-FILE-LAYOUT))
	  NUM4 (PARSE-INTEGER-CAR (CADDDR PRINT-FILE-LAYOUT))
	  NUM5 (PARSE-INTEGER-CAR (FIFTH PRINT-FILE-LAYOUT))
	  NUM6 (PARSE-INTEGER-CAR (SIXTH PRINT-FILE-LAYOUT)))
    ((AND NUM1 NUM2 (ZPLUSP NUM3) (ZPLUSP NUM4) (ZPLUSP NUM5) (ZPLUSP NUM6)
	  (PLUSP (- NUM1 NUM3 NUM4)) (PLUSP (- NUM2 NUM5 NUM6 8)))
      (SETQ *PAGE-LINES* NUM1
	    *PAGE-COLUMNS* NUM2
	    *TOP-MARGIN* NUM3
	    *BOTTOM-MARGIN* NUM4
	    *LEFT-MARGIN* NUM5
	    *RIGHT-MARGIN* NUM6) )
    (ERROR-BEEP) )
  NIL )

(SETQ PRINT-FILE-LAYOUT '(
  ("" "Enter page lines" "Length" 5)
  ("" "Enter page columns" "Width" 5)
  ("" "Enter margin lines" "Top" 5)
  ("" "Enter margin lines" "Bottom" 5)
  ("" "Enter margin columns" "Left" 5)
  ("" "Enter margin columns" "Right" 5) ))


(SETQ *FIRST-PAGE* "")
(SETQ *LAST-PAGE* "")

(DEFUN PRINT-FILE-OPTIONS (
    NUM1 NUM2)
  (RPLACA (CADR PRINT-FILE-OPTIONS) *FIRST-PAGE*)
  (RPLACA (CADDR PRINT-FILE-OPTIONS) *LAST-PAGE*)
  (LOOP
    ((NOT (MODE-QUERY PRINT-FILE-OPTIONS)))
    (SETQ NUM1 (CAADR PRINT-FILE-OPTIONS)
	  NUM1 (IF (EQ NUM1 "") NUM1 (PARSE-INTEGER NUM1))
	  NUM2 (CAADDR PRINT-FILE-OPTIONS)
	  NUM2 (IF (EQ NUM2 "") NUM2 (PARSE-INTEGER NUM2)))
    ((AND NUM1 (OR (EQ NUM1 "") (PLUSP NUM1))
	  NUM2 (OR (EQ NUM2 "") (PLUSP NUM2)))
      (SETQ *FIRST-PAGE* NUM1
	    *LAST-PAGE* NUM2) )
    (ERROR-BEEP) )
  NIL )

(SETQ PRINT-FILE-OPTIONS '(
	("All" "Select option" "Range" ("All" "Pages"))
	("" "Enter page number" "First" 5)
	("" "Enter page number" "Last" 5)
	("Truncate" "Select option" "Lines" ("Truncate" "Wrap")) ))


(DEFUN PRINT-FILE-PRINTER (
    FILE-NAME)
  (SETQ FILE-NAME *FILE-NAME*)
  (LOOP
    (SETQ FILE-NAME (PROMPT-TEXT-FILE FILE-NAME *DEFAULT-TYPE*))
    ((EQ FILE-NAME "") NIL)
    ((PROBE-FILE FILE-NAME)
      (OPEN-INPUT-FILE FILE-NAME)
      (OPEN-OUTPUT-FILE *PRINTER-DEVICE*)
      (WRITE-STRING *INIT-PRINTER*)
      (UNWIND-PROTECT
	(PRINT-TEXT-FILE-AUX FILE-NAME)
	(CLOSE-INPUT-FILE FILE-NAME)
	(WRITE-STRING *STOP-PRINTER*)
	(CLOSE-OUTPUT-FILE *PRINTER-DEVICE*) ) )
    (ERROR-BEEP) ) )

(DEFUN PRINT-TEXT-FILE-AUX (FILE-NAME
    FILE-DATE PAGE ROW LINE ROWS COLS *TAB-EXPAND* )
  (SETQ FILE-DATE (DATE-STRING (FILE-DATE FILE-NAME))
	FILE-NAME (SUBSTRG (INPUT-FILE) 2)
	PAGE 1
	ROW 0
	COLS (- *PAGE-COLUMNS* *LEFT-MARGIN* *RIGHT-MARGIN*)
	*TAB-EXPAND* T)
  (LOOP
    ((NOT (FINDSTRING '\\ FILE-NAME)))
    (SETQ FILE-NAME (SUBSTRG FILE-NAME (ADD1 (FINDSTRING '\\ FILE-NAME)))) )
  (LOOP
    (LOOP
      ((LISTEN T)
	(CLEAR-INPUT T)
	((PROMPT-YN "Quit printing file")
	  (IF *USE-FORMFEED*
	      (WRITE-BYTE 12)
	      (TERPRI (- *PAGE-LINES* ROW)) )
	  (RETURN T) ) )
      ((OR (AND (PLUSP *LAST-PAGE*) (> PAGE *LAST-PAGE*))
	   (NOT (LISTEN)))
	(PRINT-FOOTER)
	(RETURN T) )
      (SHOW-PROMPT (PACK* "Printing page " PAGE " of " FILE-NAME))
      (SETQ LINE (READ-LINE))
      ( ((FINDSTRING (ASCII 12) LINE)
	  (SETQ LINE (PACK (DELETE (ASCII 12) (UNPACK LINE))))
	  (PRINT-FOOTER) ) )
      (LOOP
	( ((ZEROP ROW)
	    (SETQ ROW *TOP-MARGIN*)
	    ((PRINT-PAGEP)
	      (WRITE-BYTE 13)
	      (TERPRI *TOP-MARGIN*) ) ) )
	( ((AND (EQ LINE "") (EQ ROW *TOP-MARGIN*)))
	  ( ((PRINT-PAGEP)
	      (WRITE-BYTE 32 *LEFT-MARGIN*)
	      (WRITE-LINE (SUBSTRG LINE 0 COLS)) ) )
	  (SETQ LINE (SUBSTRG LINE COLS))
	  ((>= (INCQ ROW) (- *PAGE-LINES* *BOTTOM-MARGIN*))
	    (PRINT-FOOTER) ) )
	((EQ LINE ""))
	((EQ (CAR (CADDDR PRINT-FILE-OPTIONS)) "Truncate")) ) ) ) )

(DEFUN PRINT-FOOTER ()
  ((ZEROP ROW))
  ( ((PRINT-PAGEP)
      ( ((>= ROW (- *PAGE-LINES* *FOOTER-MARGIN*)))
	(TERPRI (- *PAGE-LINES* *FOOTER-MARGIN* ROW 1))
	(SETQ ROW (- *PAGE-LINES* *FOOTER-MARGIN*))
	(WRITE-BYTE 32 *LEFT-MARGIN*)
	(WRITE-STRING FILE-NAME)
	(SPACES (- (TRUNCATE COLS 2) (SPACES) 2))
	(WRITE-STRING (PACK* '- PAGE '-))
	(SPACES (- COLS (SPACES) (STRING-LENGTH FILE-DATE) 4))
	(WRITE-LINE FILE-DATE) )
      ((NOT *USE-FORMFEED*)
	(TERPRI (- *PAGE-LINES* ROW)) )
      (WRITE-BYTE 12) ) )
  (SETQ ROW 0)
  (INCQ PAGE) )

(DEFUN PRINT-PAGEP ()
  ((EQ (CAAR PRINT-FILE-OPTIONS) "All"))
  ((AND (PLUSP *FIRST-PAGE*) (< PAGE *FIRST-PAGE*))  NIL)
  (NOT (AND (PLUSP *LAST-PAGE*) (> PAGE *LAST-PAGE*))) )

(DEFUN DATE-STRING (DATE)
  (PACK* (IF (< (SECOND DATE) 10) 0 "")  (SECOND DATE)	'/
	 (IF (< (THIRD DATE)  10) 0 "")  (THIRD DATE)	'/
	 (SUBSTRG (FIRST DATE) 2)) )

(DEFUN ZPLUSP (NUM)
  ((PLUSP NUM))
  (ZEROP NUM) )


(DEFUN STRING-LENGTH (STRING)
  ((SYMBOLP STRING)
    ((NULL STRING) 3)
    (LENGTH STRING) ) )

(DEFUN SUBSTRG (STRING INDEX CTR)
  ((ZEROP CTR) "")
  (SUBSTRING STRING INDEX (IF (PLUSP CTR) (+ INDEX CTR -1))) )


(DEFUN EDIT-STATUS ()
  (SETQ *EDIT-STATUS* T)
  (CLEAR-STATUS "Edit")
  (WRITE-STRING "File: ")
  (WRITE-STRING *FILE-NAME*)
  ((SMALL-SCREENP))
  (SET-CURSOR 0 31)
  (WRITE-STRING "Row:	   Col:")
  (SET-CURSOR 0 35)
  (PRIN1 (ADD1 *POINT-ROW*))
  (SET-CURSOR 0 45)
  (PRIN1 (ADD1 *POINT-COL*))
  (SETQ *STAT-ROW* *POINT-ROW*
	*STAT-COL* *POINT-COL*) )


(SETQ *START-BLOCK* 0)
(SETQ *END-BLOCK* 1)
(SETQ *LAST-POSN* 2)
(SETQ *FIND-POSN* 3)
(SETQ *TEMP-POSN* 4)

(DEFUN SET-USER-MARK (BYTE)
  ((<= 48 BYTE 51)
    (SET-MARK (- BYTE 43)) ) )

(DEFUN JUMP-USER-MARK (BYTE)
  ((<= 48 BYTE 51)
    (JUMP-TO-MARK (- BYTE 43)) ) )

(DEFUN SET-MARK (MARK ROW COL)
  (RPLACA (NTH MARK *MARK-LIST*) (OR ROW *POINT-ROW*))
  (RPLACD (NTH MARK *MARK-LIST*) (OR COL *POINT-COL*)) )

(DEFUN MARK-ROW (MARK)
  (CAR (NTH MARK *MARK-LIST*)) )

(DEFUN MARK-COL (MARK)
  (CDR (NTH MARK *MARK-LIST*)) )


(DEFUN TRIM-TEXT (TEXT)
  (NREVERSE (MEMBER "" (NREVERSE TEXT) 'NEQ)) )

(DEFUN WORD-DELIMITERP (CHAR)
; ((MEMBER CHAR '(\* \-)) NIL)
  (NOT (ALPHANUMERICP CHAR)) )

(DEFUN WHITESPACEP (CHAR)
  (EQ CHAR " ") )

(DEFUN NON-WHITESPACEP (CHAR)
  (NEQ CHAR " ") )

(SETQ *LPAR* '\()
(SETQ *RPAR* '\))
(SETQ *DELETED-TEXT* NIL)

(IF (PROGN (TERPRI 2 T)
	   (WRITE-STRING "Make editor WordStar-like or EMACS-like? (W/E) " T)
	   (< (LOOP ((POSITION (READ-BYTE T) '(87 119 69 101)))) 2))


;	* * *	WordStar-like control key assignments	* * *
(PROGN
(WRITE-STRING 'W T)

(SETQ *EDIT-DEMONS* '(
	(8 . DELETE-LEFT-CHAR)		;Ctrl-H
	(9 . JUMP-RIGHT-TAB)		;Ctrl-I
	(13 . ADD-NEWLINE)		;Ctrl-M 	Update *LOCAL-DEMONS*

	(1 . JUMP-LEFT-WORD)		;Ctrl-A
	(3 . SCROLL-UP-SCREEN)		;Ctrl-C
	(4 . JUMP-RIGHT-CHAR)		;Ctrl-D
	(5 . JUMP-UP-LINE)		;Ctrl-E
	(6 . JUMP-RIGHT-WORD)		;Ctrl-F
	(7 . DELETE-RIGHT-CHAR) 	;Ctrl-G
	(10 . DOWN-LINE-INDENT) 	;Ctrl-J
	(11 . CTRL-COMMAND)		;Ctrl-K
	(12 . FIND-TEXT-STRING) 	;Ctrl-L
	(14 . INSERT-NEWLINE)		;Ctrl-N
	(15 . EDIT-BLOCK)		;Ctrl-O
	(16 . ADD-ESCAPE-CHAR)		;Ctrl-P
	(17 . CTRL-COMMAND)		;Ctrl-Q
	(18 . SCROLL-DOWN-SCREEN)	;Ctrl-R
	(19 . JUMP-LEFT-CHAR)		;Ctrl-S
	(20 . DELETE-RIGHT-WORD)	;Ctrl-T
	(21 . UNDELETE-TEXT)		;Ctrl-U
	(23 . SCROLL-DOWN-LINE) 	;Ctrl-W
	(24 . JUMP-DOWN-LINE)		;Ctrl-X
	(25 . DELETE-TEXT-LINE) 	;Ctrl-Y
	(26 . SCROLL-UP-LINE)		;Ctrl-Z
	(30 . CTRL-COMMAND)		;Ctrl-^
	(31 . DELETE-LEFT-CHAR) 	;Ctrl-_
	(127 . DELETE-LEFT-CHAR)	;Rub

	(-79 . JUMP-RIGHT-END)		;End
	(-71 . JUMP-LEFT-END)		;Home
	(-117 . JUMP-BOTTOM-SCREEN)	;Ctrl-End
	(-119 . JUMP-TOP-SCREEN)	;Ctrl-Home
	(-118 . JUMP-END-TEXT)		;Ctrl-PgDn
	(-132 . JUMP-START-TEXT)	;Ctrl-PgUp

	(-15 . JUMP-LEFT-TAB)		;Shift-Tab
	(-19 . JUMP-THIS-DEFN)		;Alt-R
	(-20 . DELETE-SEXP)		;Alt-T
	(-31 . JUMP-LEFT-SEXP)		;Alt-S
	(-32 . JUMP-RIGHT-SEXP) 	;Alt-D
	(-46 . JUMP-NEXT-DEFN)		;Alt-C
	(-120 . EVAL-SEXP) ))		;Alt-! or Alt-1

(SETQ *CTRLQ-DEMONS* '(
	(1 . REPLACE-TEXT)		;Ctrl-Q A
	(2 . JUMP-BLOCK-START)		;Ctrl-Q B
	(3 . JUMP-END-TEXT)		;Ctrl-Q C
	(4 . JUMP-RIGHT-END)		;Ctrl-Q D
	(5 . JUMP-TOP-SCREEN)		;Ctrl-Q E
	(6 . SEARCH-TEXT)		;Ctrl-Q F
	(8 . DELETE-LEFT-END)		;Ctrl-Q H
	(9 . JUMP-LEFT-TAB)		;Ctrl-Q I
	(11 . JUMP-BLOCK-END)		;Ctrl-Q K
	(12 . REPEAT-REPLACE-TEXT)	;Ctrl-Q L
	(16 . JUMP-LAST-POSN)		;Ctrl-Q P
	(18 . JUMP-START-TEXT)		;Ctrl-Q R
	(19 . JUMP-LEFT-END)		;Ctrl-Q S
	(20 . DELETE-LEFT-WORD) 	;Ctrl-Q T
	(22 . JUMP-LAST-SEARCH) 	;Ctrl-Q V
	(24 . JUMP-BOTTOM-SCREEN)	;Ctrl-Q X
	(25 . DELETE-RIGHT-END) 	;Ctrl-Q Y
	(48 . JUMP-USER-MARK)		;Ctrl-Q 0
	(49 . JUMP-USER-MARK)		;Ctrl-Q 1
	(50 . JUMP-USER-MARK)		;Ctrl-Q 2
	(51 . JUMP-USER-MARK)		;Ctrl-Q 3
	(127 . DELETE-LEFT-END) ))	;Ctrl-Q Rub

(SETQ *CTRLK-DEMONS* '(
	(1 . CLEAR-TEXT-FILE)		;Ctrl-K A
	(2 . MARK-BLOCK-START)		;Ctrl-K B
	(3 . COPY-BLOCK)		;Ctrl-K C
	(4 . SAVE-TEXT-FILE)		;Ctrl-K D
	(11 . MARK-BLOCK-END)		;Ctrl-K K
	(17 . CLEAR-TEXT-FILE)		;Ctrl-K Q
	(18 . MERGE-TEXT-FILE)		;Ctrl-K R
	(19 . SAVE-TEXT-FILE)		;Ctrl-K S
	(22 . MOVE-BLOCK)		;Ctrl-K V
	(23 . WRITE-BLOCK)		;Ctrl-K W
	(25 . DELETE-BLOCK)		;Ctrl-K Y
	(48 . SET-USER-MARK)		;Ctrl-K 0
	(49 . SET-USER-MARK)		;Ctrl-K 1
	(50 . SET-USER-MARK)		;Ctrl-K 2
	(51 . SET-USER-MARK) )) 	;Ctrl-K 3

(SETQ *CTRL^-DEMONS* '(
	(3 . JUMP-NEXT-DEFN)		;Ctrl-^ C
	(4 . JUMP-RIGHT-SEXP)		;Ctrl-^ D
	(18 . JUMP-THIS-DEFN)		;Ctrl-^ R
	(19 . JUMP-LEFT-SEXP)		;Ctrl-^ S
	(20 . DELETE-SEXP)		;Ctrl-^ T
	(33 . EVAL-SEXP) ))		;Ctrl-^ !

(SETQ *EMACS-KEYS*)
)


;	* * *	EMACS-like control key assignments   * * *
(PROGN
(WRITE-STRING 'E T)

(SETQ *EDIT-DEMONS* '(
	(8 . DELETE-LEFT-CHAR)		;Ctrl-H
	(9 . JUMP-RIGHT-TAB)		;Ctrl-I
	(13 . ADD-NEWLINE)		;Ctrl-M 	Update *LOCAL-DEMONS*

	(0 . MARK-BLOCK-START)		;Ctrl-@
	(1 . JUMP-LEFT-END)		;Ctrl-A
	(2 . JUMP-LEFT-CHAR)		;Ctrl-B
	(4 . DELETE-RIGHT-CHAR) 	;Ctrl-D
	(5 . JUMP-RIGHT-END)		;Ctrl-E
	(6 . JUMP-RIGHT-CHAR)		;Ctrl-F
	(10 . DOWN-LINE-INDENT) 	;Ctrl-J
	(11 . DELETE-RIGHT-END) 	;Ctrl-K
	(12 . FIND-TEXT-STRING) 	;Ctrl-L
	(14 . JUMP-DOWN-LINE)		;Ctrl-N
	(15 . INSERT-NEWLINE)		;Ctrl-O
	(16 . JUMP-UP-LINE)		;Ctrl-P
	(17 . ADD-ESCAPE-CHAR)		;Ctrl-Q
	(19 . SEARCH-TEXT)		;Ctrl-S
	(21 . CTRL-COMMAND)		;Ctrl-U
	(22 . SCROLL-UP-SCREEN) 	;Ctrl-V
	(23 . DELETE-BLOCK)		;Ctrl-W
	(24 . CTRL-COMMAND)		;Ctrl-X
	(25 . UNDELETE-TEXT)		;Ctrl-Y
	(26 . CTRL-COMMAND)		;Ctrl-Z
	(31 . DELETE-LEFT-WORD) 	;Ctrl-_
	(127 . DELETE-LEFT-WORD)	;Rub

	(-17 . WRITE-BLOCK)		;Alt-W
	(-19 . MERGE-TEXT-FILE) 	;Alt-R
	(-30 . CLEAR-TEXT-FILE) 	;Alt-A
	(-31 . SAVE-TEXT-FILE)		;Alt-S
	(-32 . DELETE-RIGHT-WORD)	;Alt-D
	(-33 . JUMP-RIGHT-WORD) 	;Alt-F
	(-37 . DELETE-LEFT-END) 	;Alt-K
	(-47 . SCROLL-DOWN-SCREEN)	;Alt-V
	(-48 . JUMP-LEFT-WORD)		;Alt-B

	(-79 . JUMP-RIGHT-END)		;End
	(-71 . JUMP-LEFT-END)		;Home
	(-117 . JUMP-BOTTOM-SCREEN)	;Ctrl-End
	(-119 . JUMP-TOP-SCREEN)	;Ctrl-Home
	(-118 . JUMP-END-TEXT)		;Ctrl-PgDn
	(-132 . JUMP-START-TEXT)	;Ctrl-PgUp

	(-120 . EVAL-SEXP)		;Alt-! or Alt-1
	(-124 . REPLACE-TEXT) ))	;Alt-% or Alt-5

(SETQ *CTRLX-DEMONS* '(
	(1 . CLEAR-TEXT-FILE)		;Ctrl-X A
	(2 . JUMP-LEFT-WORD)		;Ctrl-X B
	(4 . DELETE-RIGHT-WORD) 	;Ctrl-X D
	(6 . JUMP-RIGHT-WORD)		;Ctrl-X F
	(9 . TOGGLE-INSERT)		;Ctrl-X I
	(11 . DELETE-LEFT-END)		;Ctrl-X K
	(12 . REPEAT-REPLACE-TEXT)	;Ctrl-X L
	(18 . MERGE-TEXT-FILE)		;Ctrl-X R
	(19 . SAVE-TEXT-FILE)		;Ctrl-X S
	(22 . SCROLL-DOWN-SCREEN)	;Ctrl-X V
	(23 . WRITE-BLOCK)		;Ctrl-X W
	(37 . REPLACE-TEXT)		;Ctrl-X %
	(60 . JUMP-START-TEXT)		;Ctrl-X <
	(62 . JUMP-END-TEXT) )) 	;Ctrl-X >

(SETQ *CTRLU-DEMONS* '(
	(2 . MARK-BLOCK-START)		;Ctrl-U B
	(3 . COPY-BLOCK)		;Ctrl-U C
	(4 . DELETE-BLOCK)		;Ctrl-U D
	(5 . MARK-BLOCK-END)		;Ctrl-U E
	(13 . MOVE-BLOCK) ))		;Ctrl-U M

(SETQ *CTRLZ-DEMONS* '(
	(2 . JUMP-LEFT-SEXP)		;Ctrl-Z B
	(5 . EVAL-SEXP) 		;Ctrl-Z E
	(6 . JUMP-RIGHT-SEXP)		;Ctrl-Z F
	(11 . DELETE-SEXP)		;Ctrl-Z K
	(33 . EVAL-SEXP)		;Ctrl-Z !
	(40 . JUMP-LEFT-SEXP)		;Ctrl-Z (
	(41 . JUMP-RIGHT-SEXP)		;Ctrl-Z )
	(91 . JUMP-THIS-DEFN)		;Ctrl-Z [
	(93 . JUMP-NEXT-DEFN) ))	;Ctrl-Z ]

(SETQ *EMACS-KEYS* '(
	(-72 . 16)			;Up arrow	Ctrl-P
	(-80 . 14)			;Down arrow	Ctrl-N
	(-75 . 2)			;<--		Ctrl-B
	(-77 . 6)			;-->		Ctrl-F
	(-73 . -47)			;PgUp		Alt-V
	(-81 . 22)			;PgDn		Ctrl-V
	(-115 . -48)			;Ctrl <--	Alt-B
	(-116 . -33)			;Ctrl -->	Alt-F
	(-82 . 15)			;Ins		Ctrl-O
	(-83 . 4) ))			;Del		Ctrl-D

(SETQ *EMACS-DEMONS* '(
	(-23 . TOGGLE-INSERT)		;Alt-I
	(-59 . NEXT-WINDOW)		;F1
	(-84 . LAST-WINDOW)		;Shift F1
	(-60 . NEXT-PANE)		;F2
	(-85 . LAST-PANE) ))		;Shift F2
) )

;	* * *	User adjustable control variables   * * *

(SETQ *INIT-PRINTER*	"")	;Printer's initialization string
(SETQ *STOP-PRINTER*	"")	;Printer's termination string
(SETQ *PRINTER-DEVICE*	'PRN)	;Printer device name (e.g. LPT2)
(SETQ *USE-FORMFEED*	NIL)	;Output a FORMFEED between pages if nonNIL

(SETQ *DEFAULT-TYPE*	'LSP)	;Default file name extension
(SETQ *CASE-IGNORE*	NIL)	;Ignore case during string searches if nonNIL
(SETQ *USE-TABS*	T)	;Use tab chars when saving files if nonNIL

(OR (GETD 'WINDOWS T)
    (LOAD "WINDOWS.LSP")
    (SOME '(LAMBDA (FILE)
	     (SETQ FILE (NREVERSE (UNPACK FILE)))
	     (LOAD (PACK (NREVERSE (OR (MEMBER '\\ FILE) (MEMBER ': FILE))
				   (LIST "WINDOWS.LSP")))) )
	  (INPUT-FILES) )
    (TERPRI NIL T)
    (WRITE-LINE "Cannot find WINDOWS.LSP" T) )

(FRESH-LINE)
(IF (GETD 'WINDOWS)
    (WRITE-LINE "Press the ESC key to start the muLISP editor.") )
